SuperHack/SuperHack CD.bin/CODING/MISC/MAG04.ZIP/MAG04.PAS

Pascal/Delphi Source File | 1995-10-27 | 6.2 KB | 266 lines

Program Static_Screen;

Uses Crt;                       { CRT has some good general routines in it }

Const VGA=$A000;

Type RgbItem=Record
                   R,G,B:Byte;
             End;
     RgbList=Array[0..255] of RgbItem;

Var Pal1:RgbList;
    X1,Y1,X2,Y2:Word;
    Ix1,Ix2,Iy1,Iy2:ShortInt;
    Col:Byte;
    C:Char;
    R:Word;

Procedure Initgraph; Assembler;
Asm
   Mov AH,0
   Mov AL,13h
   Int 10h
End;

Procedure Closegraph; Assembler;
Asm
   Mov AH,0
   Mov AL,03h
   Int 10h
End;

Procedure WaitVBL; Assembler;
Label A1,A2;
Asm
   Mov DX,3DAh
   A1:
      In AL,DX
      And AL,08h
      Jnz A1
   A2:
      In AL,DX
      And AL,08h
      Jz A2
End;

Procedure PutPixel(X,Y,C:Word);
Begin
     Mem[VGA:(Y*320)+X]:=C;
End;

Procedure GetColor(Col:Byte;Var R,G,B:Byte);
Begin
     Port[$3C7]:=Col;
     R:=Port[$3C9];
     G:=Port[$3C9];
     B:=Port[$3C9];
End;

Procedure SetColor(Col,R,B,G:Byte);
Begin
     Port[$3C8]:=Col;
     Port[$3C9]:=R;
     Port[$3C9]:=G;
     Port[$3C9]:=B;
End;

Procedure GetPalette(Var Pal:RgbList);
Var A:Byte;
Begin
     For A:=0 To 255 do GetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure SetPalette(Pal:RgbList);
Var A:Byte;
Begin
     WaitVBL;
     For A:=0 To 255 do SetColor(A,Pal[A].R,Pal[A].G,Pal[A].B);
End;

Procedure SetBlack(Var Pal:RgbList);
Var A:Byte;
Begin
     For A:=0 to 255 Do
     Begin
          Pal[A].R:=0;
          Pal[A].G:=0;
          Pal[A].B:=0;
     End;
End;

Procedure Cls(Col:Byte);
Begin
     FillChar(Mem[$A000:0000],64000,Col);
End;

Procedure RotatePal(Var Pal:RgbList;First,Last:Byte);
Var Temp:RgbItem;
    A:Byte;
Begin
     Temp:=Pal[Last];
     For A:=Last-1 DownTo First Do
     Begin
          Pal[A+1]:=Pal[A];
     End;
     Pal[First]:=Temp;
End;

Procedure LoadPal(Filename:String;Var Pal:RgbList); { This loads a palette    }
Var F:File;                                         { from disk... I will     }
Begin                                               { explain it in a future  }
     Assign(F,Filename);                            { article, all about disk }
     Reset(F,1);                                    { access...               }
     Blockread(F,Ptr(Seg(Pal[0].R),Ofs(Pal[0].R))^,768);
     Close(F);
End;

Procedure InitLines;
Begin
     X1:=180;
     Y1:=100;
     X2:=150;
     Y2:=140;
     Ix1:=3-Random(6); If Ix1=0 Then Ix1:=1;
     Iy1:=3-Random(6); If Iy1=0 Then Iy1:=1;
     Ix2:=3-Random(6); If Ix2=0 Then Ix2:=1;
     Iy2:=3-Random(6); If Iy2=0 Then Iy2:=1;
     Col:=2;
     LoadPal('Mag04.Pal',Pal1);
     SetPalette(Pal1);
     Cls(0);
End;

Procedure Circle(X,Y,R:Integer;Col:Byte);
Var Px,Py:Integer;
    Deg:Real;
Begin
     Deg:=0;
     Repeat
           Px:=Round(R*Sin(Deg))+X;
           Py:=Round(R*Cos(Deg))+Y;
           PutPixel(Px,Py,Col);
           Deg:=Deg+0.005;
     Until Deg>2*PI;
End;

Procedure Circles;
Begin
     LoadPal('Mag04.Pal',Pal1);
     SetPalette(Pal1);
     For R:=1 To 99 Do Circle(160,100,R,R*2);
     Repeat
           If Keypressed Then If Readkey=Chr(27) Then Exit;
           RotatePal(Pal1,1,255);
           SetPalette(Pal1);
     Until False;
End;

Function sgn(A:Real):Integer;
Begin
     If A>0 then Sgn:=+1;
     If A<0 then Sgn:=-1;
     If A=0 then Sgn:=0;
End;

Procedure Line(X1,Y1,X2,Y2,Col:Integer);
Var Deltax,S,Deltay,Dx1,Dy1,Dx2,Dy2,S1,S2:Real;
    I:Integer;
Begin
     Deltax:=X2-X1;
     Deltay:=Y2-Y1;
     Dx1:=Sgn(Deltax);
     Dy1:=Sgn(Deltay);
     Dx2:=Sgn(Deltax);
     Dy2:= 0;
     S1:=Abs(Deltax);
     S2:=Abs(Deltay);
     If Not (S1>S2) Then
     Begin
          Dx2:=0;
          Dy2:=Sgn(Deltay);
          S1:=Abs(Deltay);
          S2:=Abs(Deltax);
     End;
     S:=Int(S1/2);
     For I:=0 To Round(S1) Do
     Begin
          PutPixel(X1,Y1,Col);
          S:=S+S2;
          If Not (S<S1) Then
          Begin
               S:=S-S1;
               X1:=X1+Round(Dx1);
               Y1:=Y1+Round(Dy1);
          End
          Else
          Begin
               X1:=X1+Round(dx2);
               Y1:=Y1+Round(Dy2);
          End;
     End;
End;

Procedure Lines;
Begin
     Repeat
           WaitVbl;
           Line(X1,Y1,X2,Y2,Col);
           X1:=X1+Ix1;
           Y1:=Y1+Iy1;
           X2:=X2+Ix2;
           Y2:=Y2+Iy2;
           If (X1<4) Or (X1>315) Then Ix1:=-Ix1;
           If (Y1<5) Or (Y1>195) Then Iy1:=-Iy1;
           If (X2<4) Or (X2>315) Then Ix2:=-Ix2;
           If (Y2<5) Or (Y2>195) Then Iy2:=-Iy2;
           If Col=254 Then Col:=1;
           Inc(Col);
           RotatePal(Pal1,1,254);
           SetPalette(Pal1);
           If KeyPressed Then
           Begin
                C:=Readkey;
                If C=' ' Then
                Begin
                     Cls(0);
                     Ix1:=3-Random(6); If Ix1=0 Then Ix1:=1;
                     Iy1:=3-Random(6); If Iy1=0 Then Iy1:=1;
                     Ix2:=3-Random(6); If Ix2=0 Then Ix2:=1;
                     Iy2:=3-Random(6); If Iy2=0 Then Iy2:=1;
                End;
                If C=Chr(27) Then Exit;
           End;
     Until False;
End;

Begin
     Randomize;                       { Resets the random number generator }
     Clrscr;
     Writeln('Hello to another SpellCaster production...');
     Writeln('This one only has lines and circles, and it isn''t');
     Writeln('half as impressive as the Color Blind demo, but');
     Writeln('this issue is already very late...');
     Writeln;
     Writeln('Press SPACE to clear the screen in the lines section');
     Writeln('and ESC to exit any of the sections...');
     Repeat Until Keypressed;
     Initgraph;
     InitLines;
     Lines;
     Circles;
     Closegraph;
     Writeln('Did you liked it ?... ');
     Writeln('I hope you did.');
     Writeln('Write to ''The Mag'':');
     Writeln('Snail Mail: Praceta Carlos Manito Torres, nº4 / 6ºC');
     Writeln('            2900 Setúbal');
     Writeln('                 Portugal');
     Writeln;
     Writeln('E-Mail: [e-mail]');
     Writeln;
     Writeln;
     Writeln;
     Repeat Until Keypressed;
End.